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ABSTRACT 

These FORTRAN programs and MATHEMATICA routines were 
developed in the course of a research project titled "Achievement and 
Assessment in School Science: Modeling and Mapping Ability and 
Performance." Their use is described in other publications from that 
project, including "Latent Traits or Latent States? The Role of 
Discrete Models for Ability and Performance." Four FORTRAN programs 
(CLOSURE, DISATT, INTERSECT, and SUPERCLOSE) and one set of 
MATHEMATICA routines (Ability/Task Representations) are included. The 
use of each program is described in the comments included in the 
source code listings. (Author/SLD) 
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Edward H. Haertel 
Stanford University 
July 1996 

These FORTRAN programs and MATHEMATICA routines were 
developed in the course of a research project titled 
"Achievement and Assessment in School Science: Modeling and 
Mapping Ability and Performance, " sponsored by the National 
Science Foundation (Award No. 9154527, Edward H. Haertel, 
Principal Investigator) . Their use is described in other 
publications of that project, including "Latent Traits or 
Latent States? The Role of Discrete Models for Ability and 
Performance," which is also available as an ERIC document. 

Four FORTRAN programs (CLOSURE, DISATT, INTERSECT, and 
SUPERCLOSE) and one set of MATHEMATICA routines (Ability/Task 
Representations) are included. The use of each program is 
described in the comments included in the source code 
listings . 
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PROGRAM TO MAP NUMBER OF LRPS IN CLOSED LATTICE AS FUNCTION OF LRPS 
INPUT. PROGRAM REQUESTS NAME OF FILE CONTAINING (USUALLY) LIST OF 
HIGH-FREQUENCY MANIFEST PATTERNS. LIMIT OF 30 ELEM ENTS IN PATTERN. 
STORAGE OVERFLOW WILL BE DETECTED. 
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* PERMISSION IS GRANTED TO USE THIS PROGRAM * 

* FOR NONCOMMERCIAL PURPOSES PROVIDED THE * 

* ORIGINAL AUTHOR IS CREDITED. NO WARRANTY * 

* AS TO THE ACCURACY OR UTILITY OF THE * 

* PROGRAM FOR ANY PURPOSE IS EXPRESSED * 

* OR IMPLIED. PERMISSION IS ALSO GRANTED * 

* TO MODIFY THE PROGRAM AND/OR TO INCORPORATE * 

* THIS CODE OR ALGORITHMS INTO OTHER * 

* PROGRAMS FOR NONCOMMERCIAL PURPOSES. * 

* * 



*************************************************** 



MODIFIED 3/26/92 TO PROVIDE ADDITIONAL OUTPUT AND ANALYSIS 

INTEGER LIST (2, 5000) ,TEMP(3, 1000) , IN(30) 

REAL*8 FREQ, CFREQ, RATIO 
CHARACTER* 80 FILENAME, FORMAT 
CHARACTER* 40 BLANK 
LOGICAL EXIST 
COMMON/ START / ISTART 

DATA BLANK/ ' 1 / 

WRITE (9, 80) 'NUMBER OF ITEMS IN EACH PATTERN' 

READ(9, 81)NI 

80 FORMAT (A) 

81 FORMAT (120) 

ISTART=2** (NI-1) 

WRITE(9, 80) 'NUMBER OF PATTERNS TO BE READ' 

READ(9, 8DMAXIN 
I SER=MAXIN+ 1 

2 WRITE (9, 80) ' INPUT FILENAME' 

READ ( 9 , 80 ) FILENAME 

INQUIRE (FILE=FILENAME, EXIST= EXIST) 

IF (EXIST) GO TO 3 

WRITE (9, 80) 'FILE NOT FOUND' 

GO TO 2 

3 OPEN (11, FILE=FILENAME) 

WRITE (9, 80) 'INPUT DATA FORMAT FOR FREQUENCY (F FORMAT) ' 
WRITE (9, 80) 'FOLLOWED BY PATTERN VECTOR (I FORMAT) ' 

READ (9, 80) FORMAT 

WRITE (9, 80) 'OUTPUT FILENAME FOR FUNCTION VALUES AND STATS' 
READ ( 9 , 80 ) FILENAME 
OPEN ( 12 , F ILE=F ILENAME ) 
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WRITE (9, 80) 'OUTPUT FILENAME FOR COMPLETED LRP LIST' 

READ ( 9 , 80 ) FILENAME 
OPEN ( 13 , FILE=FILENAME) 

C INITIALIZE AND INPUT FIRST CASE 

NIN=1 
NOUT=l 

READ (11, FORMAT) FREQ, (IN(I) , 1=1, NI) 

CFREQ=FREQ 
RAT 10=1 .DO 

WRITE (9, 83 )NIN,NOUT,NOUT-NIN, FREQ, CFREQ, RATIO, (IN(I) , 1=1, NI) 

WRITE (12, 83)NIN,NOUT,NOUT-NIN, FREQ, CFREQ, RATIO, (IN(I) , 1=1, NI) 

82 FORMAT (3011) 

C**** THE FOLLOWING FORMAT IS INCONSISTENT WITH PROGRAM SPECS ABOVE. IF 
C**** NUMBER OF ITEMS IS GREATER THAT ABOUT 10, CHANGE 'T40' TO 'T54' IN 
C**** FORMAT 83 

83 FORMAT (315 , T40, F7 . 3, F9 . 3 , F6 . 3 , T21, 3011) 

£★ ★ ★ ★ 

LIST (1, 1) =1 

LIST (2, 1)=IPACK(IN,NI) 

C HERE TO INPUT NEXT VALUE 

1 IF (NIN. GE. MAXIN) GO TO 40 
NIN=NIN+1 

READ (11, FORMAT) FREQ, (IN(I) , 1=1, NI) 

CFREQ=CFREQ+-FREQ 
NEW= IPACK ( IN , NI ) 

C CHECK IF NEW IS ALREADY IN THE LIST, AND STORE IN TEMP IF NOT 
CALL SEARCH(NEW, LIST, NOUT, IRES, IPT) 

IF ( IRES . GT . 0 ) GO TO 5 

C NEW PATTERN HAS ALREADY BEEN ADDED — REPLACE SERIAL NUMBER 
LIST (1, IPT) =NIN 
RAT IO=DFLOAT (NOUT) /DFLOAT (NIN) 

WRITE (9, 83 )NIN, NOUT, NOUT-NIN, FREQ, CFREQ, RATIO, (IN (I) , 1=1, NI) 
WRITE(12, 83)NIN, NOUT, NOUT-NIN, FREQ, CFREQ, RATIO, (IN(I) , 1=1, NI) 

GO TO 1 

5 TEMP (1,1) =NEW 
TEMP (2, 1)=NIN 
TEMP (3, 1)=IPT 
LAST=1 

C CHECK INTERSECTIONS WITH ALL PATTERNS ALREADY IN LIST 
DO 10 1=1, NOUT 
J=INTER (NEW, LIST (2 , 1) ) 

CALL SEARCH (J, LIST, NOUT, IRES, IPT) 

IF ( IRES . EQ . 0 ) GO TO 10 
C HERE TO ADD NEW PATTERN TO LIST 

LAST=LAST+ 1 
TEMP (1, LAST) =J 
TEMP (2 , LAST) =ISER 
TEMP (3 , LAST) =IPT 
ISER=ISER+1 
10 CONTINUE 

C SORT ADDITIONAL PATTERNS, ELIMINATE DUPLICATES, AND UPDATE LIST 

KEEP=1 

IF ( LAST . EQ . 1 ) GO TO 16 
CALL SORT (TEMP, LAST, 3, 3) 

DO 15 1=2, LAST 

IF (TEMP(1, 1-1) .NE.TEMP(1, 1) )GO TO 12 
TEMP (3 , I) =-l 
GO TO 15 
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12 TEMPO, I)=TEMP(3, 1)+KEEP 
KEEP=KEEP+1 

15 CONTINUE 

16 IENDl=NOUT 
NOUT=NOUT+KEEP 
IEND=NOUT 

RAT 10= DFLOAT (NOUT) /DFLOAT (NIN) 

WRITE(9, 83) NIN,NOUT,NOUT-NIN, FREQ, CFREQ, RATIO, (IN(I) , 1=1, NI) 

WRITE (12, 83) NIN, NOUT, NOUT-NIN, FREQ, CFREQ, RATIO, (IN(I) , 1=1, NI) 

17 IF (TEMP (3, LAST) .GT.O)GO TO 18 
LAST=LAST- 1 

GO TO 17 

18 IF ( IEND-TEMP ( 3 , LAST ) ) 2 0 , 2 5 , 30 

20 WRITE (9, 80) 'A SERIOUS ERROR HAS OCCURRED. EXECUTION ABORTED (1) ' 
PAUSE 
STOP 

25 LIST ( 1 , IEND) =TEMP ( 2 , LAST ) 

LIST ( 2 , IEND) =TEMP ( 1 , LAST ) 

IEND=IEND-1 

LAST= LAST - 1 

IF (LAST . GT . 0 ) GO TO 17 

IF ( IEND . EQ . IENDl ) GO TO 1 

WRITE (9, 80) 'A SERIOUS ERROR HAS OCCURRED. EXECUTION ABORTED (2) ' 

PAUSE 

STOP 

30 DO 35 1=1, IEND-TEMP(3, LAST) 

LIST ( 1 , IEND) =LIST ( 1 , IENDl ) 

LIST ( 2 , IEND) =LIST ( 2 , IENDl ) 

IEND=IEND-1 
35 IENDl=IENDl-l 
GO TO 25 

C HERE TO OUTPUT COMPLETED PATTERN LIST 

40 CALL SORT ( LIST , NOUT ,2,2) 

DO 50 1=1, NOUT 

CALL UNPACK (LIST (2, 1) , IN, NI) 

WRITE (13, 82) ( IN ( J) , J=1,NI) 

IF ( I . EQ . MAX IN) WRITE ( 13 , 80 ) BLANK ( 1 : NI ) 

50 CONTINUE 

WRITE (9, 80) 'NORMAL TERMINATION' 

PAUSE 

STOP 

END 

INTEGER FUNCTION IPACK(IN,NI) 

INTEGER IN (NI) 

IPACK=0 
DO 5 1=1, NI 
5 IPACK=2 * IPACK+IN ( I ) 

RETURN 

END 

SUBROUTINE UNPACK( Jl, IN,NI) 

INTEGER IN (NI) 

COMMON/ START / ISTART 
1=1 
J=J1 

IBIT=ISTART 
1 IF(J-IBIT) 5, 10, 10 
5 IN(I) =0 
GO TO 15 
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10 IN(I)=1 
J=J-IBIT 
15 1=1+1 

IBIT=IBIT/2 

IF ( IBIT . GT . 0 ) GO TO 1 

RETURN 

END 

SUBROUTINE SEARCH (NEW, LIST, N, IRES, IPT) 

C RETURN 0 IF PATTERN IS IN LIST, ELSE RETURN POINTER TO NEXT HIGHER 

INTEGER LIST (2 , N) 

IL=1 

IH=N 

1 1= (IL+IH) /2 

IF (NEW-LIST (2,1) ) 5, 10, 15 
5 IH=I-1 

IF ( IH . GE . IL ) GO TO 1 
IRES=1 
IPT=I 
RETURN 
10 IRES=0 
IPT=I 
RETURN 
15 IL=I+1 

IF ( IL . LE . IH ) GO TO 1 

IRES=1 

IPT=I+1 

RETURN 

END 

INTEGER FUNCTION INTER(IN1X, IN2X) 

COMMON/ START / ISTART 

IN1=IN1X 

IN2=IN2X 

IBIT=ISTART 

INTER=0 

1 IF ( INI. LT. IBIT) GO TO 5 
IN1=IN1-IBIT 
IF (IN2.LT. IBIT) GO TO 10 
IN2 = IN2 - IBIT 
INTER= INTER+ IBIT 
GO TO 10 

5 IF (IN2.LT. IBIT) GO TO 10 
IN2=IN2-IBIT 
10 IBIT=IBIT/2 

IF ( IBIT . GT . 0 ) GO TO 1 
RETURN 
END 

SUBROUTINE SORT ( IBUF , N, LEN, ISKIP ) 

GENERAL-PURPOSE SORTING SUBROUTINE, USING ‘QUICK SORT 1 ALGORITHM 
IBUF IS VECTOR TO BE SORTED, N IS NUMBER OF ELEMENTS IN VECTOR, 

LEN IS NUMBER OF WORDS IN EACH ELEMENT, AND ISKIP (> LEN) IS NUMBER 
OF WORDS SEPARATING THE BEGINNING OF SUCCESSIVE VECTOR ELEMENTS 
LEN MUST BE LESS THAN OR EQUAL TO THE DIMENSION OF PIVOT 
INTEGER IBUF ( ISKIP, N) ,LV(40) ,UV(40) , PIVOT, P 
LV ( 1) =1 ; UV ( 1 ) =N ; P=1 
DO WHILE (P.GT.0) 

IF(LV(P) .GE.UV(P) ) THEN 
P=P-1 
ELSE 
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I=LV(P) -1 
J=UV(P) 

PIVOT=J 
1 1=1+1 

IF(I.GE.J) GO TO 10 
DO 2 KX=1,LEN 

IF ( IBUF (KX, I) -IBUF (KX, PIVOT) ) 1 , 2 , 4 
2 CONTINUE 
GO TO 1 
4 J=J-1 

IF(J.LE.I) GO TO 10 
DO 6 KX=1,LEN 

IF(IBUF(KX, J) -IBUF (KX, PIVOT) )7,6,4 

6 CONTINUE 
GO TO 4 

7 DO 8 KX=1,LEN 

L=IBUF (KX, I) 

IBUF (KX, I) =IBUF(KX, J) 

8 IBUF (KX, J) =L 
GO TO 1 

10 DO 12 KX=1, LEN 

IF ( IBUF (KX, I) - IBUF (KX, PIVOT) ) 13, 12, 14 

12 CONTINUE 

13 IF ( I. EQ. PIVOT) GO TO 16 
1 = 1+1 

14 DO 15 KX=1, LEN 
L=IBUF(KX, I) 

IBUF (KX, I)=IBUF(KX, PIVOT) 

15 IBUF (KX, PIVOT) =L 

16 IF (I-LV(P) .LT. UV (P) -I) THEN 

LV ( P+1) =LV(P) 

UV(P+1)=I-1 
LV ( P) =1+1 
ELSE 

LV (P+1) =1+1 
UV(P+1)=UV(P) 

UV(P)=I-1 
END IF 
P=P+1 
END IF 
REPEAT 
RETURN 
END 




CLOSUREV2 — page 5 



DISATT 



C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 



c 



PROGRAM TO INPUT A LIST OF MANIFEST RESPONSE PATTERNS, WITH 
FREQUENCIES, AND A SET OF HYPOTHESIZED TP AND FP RATE VECTORS 
AND CALCULATE LATENT FREQUENCIES FOR ALL POSSIBLE RESPONSE PATTERNS. 
THESE ARE THEN SORTED FROM MOST FREQUENT DOWN, AND OUTPUT. OUTPUT 
FORMAT IS (F12.3, 3X, 1011) (PROGRAM IS LIMITED TO TEN ITEMS) 
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PERMISSION IS GRANTED TO USE THIS PROGRAM * 
FOR NONCOMMERCIAL PURPOSES PROVIDED THE * 
ORIGINAL AUTHOR IS CREDITED. NO WARRANTY * 
AS TO THE ACCURACY OR UTILITY OF THE * 
PROGRAM FOR ANY PURPOSE IS EXPRESSED * 
OR IMPLIED. PERMISSION IS ALSO GRANTED * 
TO MODIFY THE PROGRAM AND/OR TO INCORPORATE * 
THIS CODE OR ALGORITHMS INTO OTHER * 
PROGRAMS FOR NONCOMMERCIAL PURPOSES. * 



*************************************************** 



IMPLICIT REAL*8 (A-H, O-Z) 

REAL*8 OMAT (1024 ) , CMATS (10, 2, 2 ) 

INTEGER PMAP(1024, 10) , SORTMAP (2 , 1024 ) , IN(10) 
CHARACTER* 80 FILENAME, FORMAT 
CHARACTER* 20 ANSWER 
LOGICAL EXIST 

WRITE (9, 80) 'NUMBER OF ITEMS' 

READ(9, 81)NI 

80 FORMAT (A) 

81 FORMAT (120) 

82 FORMAT (F20.0) 

NPAT=2**NI 

DO 5 I=1,NPAT 
5 OMAT (I) =0. DO 
CREATE PMAP 
DO 15 IP=1 , NPAT 
J=IP-1 

DO 10 11=1, NI 
I=NI+1-II 

PMAP ( IP, I) =J-2* (J/2) +1 
10 J=J/2 
15 CONTINUE 

WRITE(9, 80) 'NUMBER OF (MANIFEST) PATTERNS' 
WRITE (9, 80) ' (WITH FREQUENCIES) TO BE INPUT' 
READ(9, 81)NIN 

17 WRITE (9, 80) 'INPUT FILENAME' 

READ ( 9 , 80 ) FILENAME 

INQUIRE (FILE=FILENAME, EXIST= EXIST) 

IF (EXIST) GO TO 20 
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WRITE (9, 80) 'FILE NOT FOUND' 

GO TO 17 

20 OPEN (11, FILE=FILENAME) 

WRITE (9, 80) 'INPUT FORMAT: FREQ (TYPE F) THEN PATTERN VECTOR (TYPE 

* I) ' 

READ (9, 80) FORMAT 

WRITE (9, 80) 'OUTPUT FILENAME FOR LATENT FREQUENCY TABLE' 

READ ( 9 , 80 ) FILENAME 
OPEN ( 12 , FILE=FILENAME) 

WRITE(9, 80) 'ARE TRUE POSITIVE RATES THE SAME FOR ALL ITEMS? (Y/N) ' 
READ (9, 80) ANSWER 

IF (ANSWER(1 : 1) .NE. ' Y ' . AND . ANSWER ( 1 : 1) .NE. 'y ' )GO TO 25 
WRITE (9, 80) 'COMMON TRUE POSITIVE PROBABILITY' 

READ(9, 82) TP 
DO 22 1=1, NI 
CMATS (1,2,2) =TP 
22 CMATS (I, 1,2) =1 .D0-TP 
GO TO 30 
25 DO 27 1=1, NI 

WRITE (9, 84) 'TP' , I 
84 FORMAT (A2, ' FOR ITEM ',12) 

READ ( 9 , 82 ) CMATS (I , 2,2) 

27 CMATS ( I , 1 , 2 ) =1 . D0-CMATS (1,2,2) 

30 WRITE(9, 80) 'ARE FALSE POSITIVE RATES THE SAME FOR ALL ITEMS? (Y/N) 

* I 

READ (9, 80) ANSWER 

IF (ANSWER (1:1) . NE . ' Y ' . AND . ANSWER (1:1) . NE . ' y ' ) GO TO 35 
WRITE (9, 80) 'COMMON FALSE POSITIVE PROBABILITY' 

READ (9, 82)FP 
DO 32 1=1, NI 
CMATS (1,2,1) =FP 
32 CMATS (I, 1, 1) =1 .D0-FP 
GO TO 40 
35 DO 37 1=1, NI 

WRITE(9, 84) 'FP' , I 
READ (9,82) CMATS (1,2, 1 ) 

37 CMATS (I, 1 , 1) =1 .D0-CMATS (I, 2,1) 

C NEXT INVERT ALL 2X2 MATRICES 

40 DO 45 1=1, NI 

DET=CMATS (1,1,1) * CMATS (1,2,2) -CMATS (1,2,1) * CMATS ( 1 , 1,2) 

TP=CMATS (1,2,2) 

CMATS ( I , 2 , 2 ) =CMATS ( I , 1 , 1 ) / DET 
CMATS (1,1,1) =TP/DET 
CMATS (I, 1,2) =-CMATS ( I , 1,2) /DET 
45 CMATS (1,2,1) =-CMATS (1,2,1) /DET 
C PROCESS RESPONSE PATTERNS 

DO 60 11=1, NIN 

READ (11, FORMAT) FREQ, (IN(I) ,1=1, NI) 

DO 52 1=1, NI 
52 IN (I) =IN (I) +1 
DO 55 IP=1, NPAT 
R=FREQ 

DO 50 1=1, NI 

50 R=R*CMATS(I, PMAP(IP, I) , IN(I) ) 

55 OMAT ( IP) =OMAT (IP) +R 
60 CONTINUE 

C SET UP AND PERFORM SORT 

WRITE (9, 80) 'BEGINNING SORT' 
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DO 65 IP=1, NPAT 

SORTMAP (1 , IP) =-1000 . *OMAT ( IP) 

65 SORTMAP (2, IP) = IP 

CALL SORT ( SORTMAP , NPAT ,2,2) 

C SET UP, THEN OUTPUT 

DO 67 IP=1,NPAT 
DO 67 1=1 ,NI 

67 PMAP (IP, I) =PMAP (IP, I) -1 
DO 70 11=1, NPAT 
IP= SORTMAP (2, II) 

70 WRITE (12, 85)OMAT(IP) , (PMAP (IP, I) ,I=1,NI) 

85 FORMAT (F12 . 3 , 3X, 1011) 

WRITE (9, 80) 'NORMAL TERMINATION. HIT RETURN TO EXIT. ' 

READ (9, 80) ANSWER 

STOP 

END 

SUBROUTINE SORT ( IBUF, N, LEN, ISKIP) 

C GENERAL-PURPOSE SORTING SUBROUTINE, USING 'QUICK SORT' ALGORITHM 
C IBUF IS VECTOR TO BE SORTED, N IS NUMBER OF ELEMENTS IN VECTOR, 

C LEN IS NUMBER OF WORDS IN EACH ELEMENT, AND ISKIP (> LEN) IS NUMBER 

C OF WORDS SEPARATING THE BEGINNING OF SUCCESSIVE VECTOR ELEMENTS 

C LEN MUST BE LESS THAN OR EQUAL TO THE DIMENSION OF PIVOT 

INTEGER IBUF ( ISKIP, N) ,LV(40) ,UV(40) , PIVOT, P 
LV ( 1 ) = 1 ; UV ( 1 ) =N ; P=1 
DO WHILE (P.GT.0) 

IF(LV(P) .GE.UV(P) ) THEN 
P=P-1 
ELSE 

I=LV (P) -1 
J=UV(P) 

pivot=j 

1 i=i+i 

IF(I.GE.J) GO TO 10 
DO 2 KX=1, LEN 

IF (IBUF (KX, I) -IBUF (KX, PIVOT) )1,2,4 

2 CONTINUE 
GO TO 1 

4 J=J-1 

IF(J.LE.I) GO TO 10 
DO 6 KX=1,LEN 

IF (IBUF (KX, J) - IBUF ( KX , PIVOT) ) 7, 6, 4 

6 CONTINUE 
GO TO 4 

7 DO 8 KX=1, LEN 

L=IBUF (KX, I) 

IBUF (KX, I) =IBUF(KX, J) 

8 IBUF (KX, J) =L 
GO TO 1 

10 DO 12 KX=1,LEN 

IF (IBUF (KX, I ) - IBUF ( KX , PIVOT) ) 13, 12, 14 

12 CONTINUE 

13 IF ( I. EQ. PIVOT) GO TO 16 
1 = 1+1 

14 DO 15 KX=1,LEN 
L=IBUF (KX, I) 

IBUF (KX, I) =IBUF (KX, PIVOT) 

15 IBUF (KX, PIVOT) =L 

16 IF (I-LV(P) .LT. UV (P) -I) THEN 
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LV ( P+ 1 ) =LV ( P ) 
UV(P+1)=I-1 
LV ( P) =1+1 
ELSE 

LV ( P+1 ) =1+1 
UV(P+1)=UV(P) 
UV(P)=I-1 
END IF 
P=P+1 
END IF 
REPEAT 
RETURN 
END 
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PROGRAM TO SHOW INTERSECTIONS OF PATTERNS 

★★★★★★★★★★★★★************************ ************** 
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AUTHOR: ECWARD H. HAERTEL * 

STANFORD UNIVERSITY * 

STANFORD, CA 94305-3096 * 

HAERTELSLELAND . STANFORD . EDU * 

415-725-1251 * 

415-725-7412 (FAX) * 

* 

PERMISSION IS GRANTED TO USE THIS PROGRAM * 
FOR NONCOMMERCIAL PURPOSES PROVIDED THE * 

ORIGINAL AUTHOR IS CREDITED. NO WARRANTY * 

AS TO THE ACCURACY OR UTILITY OF THE * 

PROGRAM FOR ANY PURPOSE IS EXPRESSED * 

OR IMPLIED. PERMISSION IS ALSO GRANTED * 

TO MODIFY THE PROGRAM AND/OR TO INCORPORATE * 
THIS CODE OR ALGORITHMS INTO OTHER * 

PROGRAMS FOR NONCOMMERCIAL PURPOSES. * 



*************************************************** 



IMPLICIT INTEGER (A-Z) 

INTEGER INPAT (2000) , IN(30) ,OUT(2000) 

CHARACTER* 80 FILENAME, FORMAT 
LOGICAL EXIST 
COMMON/ START/ ISTART 

80 FORMAT (A) 

WRITE(9, 80) 'NUMBER OF ITEMS' 

READ(9, 81)NI 
ISTART=2** (NI-1) 

1 WRITE (9, 80) ’ INPUT FILENAME' 

READ ( 9 , 8 0 ) FILENAME 

INQUIRE ( FILE=FILENAME , EXIST=EXIST ) 

IF (EXIST) GO TO 5 

WRITE (9, 80) FILENAME// ' NOT FOUND' 

GO TO 1 

5 OPEN (11, FILE= FILENAME) 

WRITE (9, 80) 'NUMBER OF PATTERNS TO INPUT' 

READ(9, 81)NPAT 

81 FORMAT (120) 

WRITE (9, 80) ' INPUT FORMAT (TYPE I)' 

READ (9, 80) FORMAT 
DO 10 1= 1 , NPAT 

READ (11, FORMAT) (IN(J) , J=1,NI) 

10 INPAT ( I ) =IPACK ( IN, NI ) 

11 WRITE (9, 80) 'OUTPUT FILE' 

READ ( 9 , 8 0 ) FILENAME 

INQUIRE ( FILE=FILENAME , EXIST=EXIST ) 

IF ( .NOT. EXIST) GO TO 12 

WRITE (9, 80) FILENAME/ / ' ALREADY EXISTS. PLEASE CHOOSE ANOTHER NAME 



GO TO 11 

12 OPEN ( 12 , FILE=FILENAME) 
NCHECK= 0 
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13 WRITE (9,82) NCHECK 

82 FORMAT ( 'HAVE CHECKED' , 15, ' . HOW MANY MORE? (0 TO EXIT) ' 
READ(9, 81) INCREMENT 

IF ( INCREMENT . EQ . 0 ) STOP 
LOW=NCHECK+ 1 
H IGH=NCHECK+ INCREMENT 
NCHECK=HIGH 
DO 20 IBASE=LOW, HIGH 
DO 15 ITEST=1, IBASE 

I PAT= INTER ( INPAT (ITEST) , INPAT ( IBASE) ) 

DO 14 J=1,NPAT 

IF(IPAT.EQ. INPAT (J) )GO TO 15 

14 CONTINUE 
J=9999 

15 OUT ( ITEST) =J 

20 WRITE (12, 83) IBASE, (OUT(I) , 1=1, IBASE) 

83 F0RMAT(/I5, (T6, 3015) ) 

GO TO 13 

END 

INTEGER FUNCTION IPACK(IN,NI) 

INTEGER IN(NI) 

IPACK=0 
DO 5 1=1, NI 
5 IPACK=2 * IPACK+IN ( I ) 

RETURN 

END 

INTEGER FUNCTION INTER (IN1X, IN2X) 

COMMON/ START / ISTART 

IN1=IN1X 

IN2=IN2X 

IBIT= ISTART 

INTER=0 

1 IF ( INI . LT . IBIT ) GO TO 5 
IN1=IN1-IBIT 
IF (IN2.LT. IBIT) GO TO 10 
IN2 = IN2 - IBIT 
INTER= INTER+ IBIT 
GO TO 10 

5 IF (IN2.LT. IBIT) GO TO 10 
IN2 = IN2 - IBIT 
10 IBIT=IBIT/2 

IF ( IBIT . GT . 0 ) GO TO 1 

RETURN 

END 
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1 SUPER' -CLOSURE: PROGRAM FOR INTERACTIVE MODELING OF 

LATENT RESPONSE PATTERN LATTICE STRUCTURES. 

*************************************************** 

* 

* 

* AUTHOR: EDWARD H. HAERTEL * 

* STANFORD UNIVERSITY * 

* STANFORD, CA 94305-3096 * 

* HAERTELOLELAND . STANFORD . EDU * 

* 415-725-1251 * 

* 415-725-7412 (FAX) * 

* 

* 

* PERMISSION IS GRANTED TO USE THIS PROGRAM * 

* FOR NONCOMMERCIAL PURPOSES PROVIDED THE * 

* ORIGINAL AUTHOR IS CREDITED. NO WARRANTY * 

* AS TO THE ACCURACY OR UTILITY OF THE * 

* PROGRAM FOR ANY PURPOSE IS EXPRESSED * 

* OR IMPLIED. PERMISSION IS ALSO GRANTED * 

* TO MODIFY THE PROGRAM AND/OR TO INCORPORATE * 

* THIS CODE OR ALGORITHMS INTO OTHER * 

* PROGRAMS FOR NONCOMMERCIAL PURPOSES. * 

* 

* 

*************************************************** 

THE BASIC IDEA OF THIS PROGRAM IS THAT A SET OF (TRUE OR 
LATENT) PERFORMANCE STATE PATTERNS REPRESENTS THE UNION OF 
ONE OR MORE DISTRIBUTIVE LATTICES REPRESENTING UNIQUE ABILITY 
CONFIGURATIONS ENABLING EXECUTION OF THE RESPECTIVE ITEMS. 

IF EACH ITEM CAN BE SOLVED USING EXACTLY ONE SET OF UNDERLYING 
ABILITIES, THEN A SINGLE 'ABILITY STRUCTURE' SHOULD SUFFICE. IF 
ONE OR MORE ITEMS CAN BE SOLVED USING ONE OR MORE- DISTINCT SKILLS, 
THEN TWO OR MORE ABILITY STRUCTURES MAY BE REQUIRED, ACCOUNTING 
FOR (OVERLAPPING) SUBSETS OF THE LATENT ABILITY PATTERNS. 

THIS INTERACTIVE PROGRAM INCORPORATES CODE FROM THE EARLIER 
(NONINTERACTIVE) 'CLOSURE' PROGRAM, HENCE 'SUPER-CLOSURE'. 

IT CAN MAINTAIN UP TO 20 DATA STRUCTURES SIMULTANEOUSLY, 

AND CAN HANDLE LATENT RESPONSE PATTERNS ON UP TO 30 ITEMS. UP 
TO 2000 LATENT RESPONSE PATTERNS (WITH ASSOCIATED FREQUENCIES) 

MAY BE INPUT. 

INPUT IS A FILE CONTAINING A LIST OF 1-0 VECTORS AND 
ASSOCIATED FREQUENCIES. THE LIST IS TREATED AS ORDERED; 

USUALLY ORDER WILL BE DESCENDING FREQUENCY. THE LIST 
COULD BE EITHER OF MANIFEST RESPONSE PATTERNS OR OF 
ESTIMATED FREQUENCIES OF LATENT RESPONSE PATTERNS. LATTER 
IS THE USE I HAVE IN MIND AT THE PRESENT. SUCH A LIST IS 
GENERATED, FOR EXAMPLE, BY 'DISATT' PROGRAM, WHICH ACCEPTS 
VECTORS OF TRUE POSITIVE AND FALSE POSITIVE PROBABILITIES 
FOR A SET OF ITEMS, TOGETHER WITH MANIFEST FREQUENCIES, AND 
CALCULATES CORRESPONDING LATENT RESPONSE PATTERN FREQUENCIES. 

THE USER OF THIS PROGRAM REQUESTS PATTERNS SEQUENTIALLY FROM 
THE INPUT LIST, ALTHOUGH THERE IS AN OPTION TO MOVE AROUND 
IN THE LIST. PATTERNS ARE REFERRED TO ONLY BY THEIR INPUT 
LIST SEQUENCE NUMBERS. IT WILL BE HELPFUL TO HAVE A PRINTOUT 
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OF THE INPUT LIST AT HAND WHEN RUNNING THIS PROGRAM. 

AFTER REQUESTING NUMBER OF ITEMS, INPUT FILE NAME, AND INPUT 
FORMAT, PROGRAM READS ENTIRE LIST INTO MEMORY AND REQUESTS A 
COMMAND. EACH COMMAND CONSISTS OF A LETTER (UPPER OR LOWER 
CASE) READ IN COLUMN 1, USUALLY FOLLOWED BY A NUMBER. ONE OR 
MORE SPACES BETWEEN THE LETTER AND THE NUMBER ARE OPTIONAL. 
THE MEANING OF THE NUMBER (IF ANY) DEPENDS ON THE PRECEDING 
LETTER: 



N GET NEXT PATTERN. THIS WILL ALWAYS BE THE FIRST COMMAND, 

AND RESULTS IN DISPLAY OF “CURRENT PATTERN IS" LINE. 

AN ALTERNATIVE FORM OF THIS COMMAND IS N<#>. THIS GETS 
THE PATTERN AT LOCATION <#> IN THE INPUT LIST. SUBSEQUENT 
'N' REQUESTS WILL CONTINUE FROM THERE. IT IS PERMISSIBLE 
TO GO BACKWARD OR FORWARD. 

C<#> CHECK RESULT OF ADDING CURRENT PATTERN TO DATA STRUCTURE 

INDEXED BY <#>. ANSWER IS EITHER 'ALREADY IMPLIED' OR ELSE 
A LIST OF NEW PATTERNS IMPLIED. FOR EACH OF THESE NEW 
PATTERNS, IF IT IS IN THE ORIGINAL INPUT LIST, ITS SEQUENCE 
NUMBER AND ASSOCIATED FREQUENCY ARE GIVEN. 

A<#> ADD CURRENT PATTERN TO DATA STRUCTURE INDEXED BY <#>. 

OUTPUT OF THIS COMMAND IS IDENTICAL TO THAT OF C<#>. IF 
IMMEDIATELY PRECEDING COMMAND WAS C<#>, THE COMMAND 'A* 

MAY BE GIVEN WITHOUT A NUMBER. IN THIS CASE, THE <#> FROM 
THE ' C ' COMMAND IS IMPLIED, AND REDUNDANT OUTPUT IS SUPPRESSED. 

R<#> ERASES DATA STRUCTURE INDEXED BY <#> . IF <#> IS OMITTED, ALL 
DATA STRUCTURES ARE' PURGED. . 

EX#> DUPLICATES DATA STRUCTURE INDEXED BY <#> . THE COPY CREATED 
WILL BE ASSIGNED THE FIRST AVAILABLE INDEX NUMBER. 

S TRIGGERS REQUEST FOR OUTPUT FILE NAME, THEN UPDATES, 

SORTS, AND OUTPUTS ALL CURRENT DATA STRUCTURES ♦ UPDATING 
REFERS TO A COMPARISON OF EACH PATTERN LIST TO THE INPUT 
DATA LIST FROM THE FIRST THROUGH THE CURRENT PATTERN. FOR 
EACH MATCH, THE INTERNAL SEQUENCE NUMBER IS UPDATED SO THAT 
WHEN DATA ARE OUTPUT, EXTANT PATTERNS ARE NOT DENOTED AS 
GENERATED PATTERNS. NOTE THAT WORK CAN BE SAVED AT WILL, 

AT INTERMEDIATE POINTS IN ANALYSIS. S<#> SAVES ONLY DATA 
STRUCTURE INDICATED BY <#> . AT TIME OF SAVE, OPTIONAL 
COMMENTS MAY BE ENTERED. THESE ARE SAVED WITH THE DATA 
STRUCTURE (S) . NOTE THAT UPDATING CAN BE SUPPRESSED BY 
PRECEDING S COMMAND WITH “N 1“ 

0 OPENS NEW FILE FOR DATA OUTPUT. ONLY ONE FILE CAN BE OPEN 
AT A TIME, AND ONCE CLOSED, A FILE CANNOT BE REOPENED. 

Q QUITS IMMEDIATELY WITHOUT SAVING 

E ' EXIT ' , EQUIVALENT TO S FOLLOWED BY Q 

U UNDO LAST COMMAND (CANNOT UNDO 'S', 'O', 'Q\ 'E', OR 'U' ITSELF 

UNDO IS MEANINGLESS FOR 'C'.) 
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C L LISTS ALL PATTERNS INCLUDED IN A GIVEN STRUCTURE 

C 

C M GENERATES LATTICE MAP OF A GIVEN STRUCTURE 

C 

C I LISTS INDEX NUMBERS OF ALL PATTERNS IN STRUCTURE 

C 



C 

C 



IMPLICIT INTEGER (A-Z) 

INTEGER LIST (2, 2000, 20) , TEMP (3, 1000) , IN (30) , INPAT (2000) 

* LENGTH (20) ,NUMREQ(13) , LENGTHOLD (20) , BACKUPLIST (2 , 2000 ) 

* LBUFFER (30,27) , NDEF (13) 

REAL*8 FREQ (2000 ) 

CHARACTER* 80 FILENAME, FORMAT 
CHARACTER* 1 CMD, CODES (26 ) 

LOGICAL EXIST, OUTFILE, DISPLAY, SAVED(20) , SAVEDHOLD, LOG 
COMMON/START/FREQ, INPAT, BACKUPLIST, MAXIN, ISTART, ISER.NI 

* OUTFILE, LOG 

DATA CODES/ 'A', 'a' , 'C' , 'c', 'D\ 'd\ 'E' , 'e' , 'N' , 'n', 'O', 



' o ' 



* ’ Q ' , 'q', 'R', 'r', 'S', 's', 'U', 'u', 'L', '1', 'M', 'm', 'I', 'i'/, 

* LENGTH/20*0/ 

* NUMREQ/0, 0,1, 10*0/, NDEF/1, 1,8*0, 3*1/ 

(NUMREQ(I) =1 IFF COMMAND I REQUIRES A NUMBER AS AN ARGUMENT.) 

(NDEF ( I ) =1 IFF COMMAND I REQUIRES NUMERIC ARGUMENT BUT MAY DEFAULT) 
OUTFILE=. FALSE. 



WRITE (9, 80) 'ENTER FILENAME FOR SESSION LOG (OR JUST <CR> IF NO LOG 
* DESIRED) ' 

READ ( 9 , 8 0 ) F ILENAME 
LOG=LEN (TRIM (FILENAME) ) . GT . 0 
IF (.NOT. LOG) GO TO 4 

40 INQUIRE (FILE=FILENAME, EXIST= EXIST) 

IF ( . NOT . EXI ST ) GO TO 41 _ 

WRITE(9, 80) TRIM (FILENAME) // ' ALREADY EXISTS' 

WRITE (9, 80) 'PLEASE CHOOSE ANOTHER NAME' 

READ ( 9 , 80 ) FILENAME 
GO TO 40 

41 OPEN ( 1 , FILE=F ILENAME) 

4 WRITE (9, 80) 'NUMBER OF ITEMS IN EACH PATTERN' 

IF (LOG) WRITE (1, 80) ‘NUMBER OF ITEMS IN EACH PATTERN' 

READ (9, 81)NI 

IF(LOG ) WRITE (1, 811)NI 

811 FORMAT (12) 

80 FORMAT (A) 

81 FORMAT (120) 

ISTART=2** (NI-1) 

WRITE (9, 80) 'NUMBER OF PATTERNS TO BE READ' 

IF (LOG) WRITE (1, 80) 'NUMBER OF PATTERNS TO BE READ' 

READ (9, 81) MAXIN 

IF ( LOG ) WRITE ( 1 , 8 12 ) MAXIN 

812 FORMAT (14) 

ISER=MAXIN+1 

2 WRITE (9, 80) ' INPUT FILENAME' 

READ ( 9 , 80 ) FILENAME 

INQUIRE (FILE=F ILENAME, EXIST= EXIST) 

IF (EXIST) GO TO 3 

WRITE (9, 80) 'FILE NOT FOUND' 

GO TO 2 

3 OPEN (11 , FILE=FILENAME) 

IF (LOG ) WRITE (1, 80) ' INPUT FILENAME' 

IF (LOG ) WRITE ( 1 , 80 ) FILENAME 
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WRITE (9, 80) 'INPUT DATA FORMAT SHOULD DESCRIBE PATTERN VECTOR' 
WRITE (9, 80) ' (I FORMAT) FOLLOWED BY FREQUENCY (F FORMAT) . ' 
WRITE (9, 80) ' INPUT FORMAT' 

READ (9, 80) FORMAT 

IF (LOG) WRITE (1, 80) 'INPUT FORMAT' 

IF (LOG) WRITE (1,80) FORMAT 
DO 5 1=1 , MAXIN 

READ (11, FORMAT) (IN(J) , J=1,NI) , FREQ ( I ) 

5 INPAT (I) =IPACK ( IN, NI) 

WRITE (9, 80) 'INPUT FILE LOADED' 

WRITE (9, 80)' ' 

IF (LOG) WRITE (1,80) 'INPUT FILE LOADED' 

IF (LOG) WRITE (1, 80) ' ' 

ICOM=0 

NEXT=0 

NUM=0 

C HERE AT BEGINNING OF COMMAND LOOP 
1 WRITE(9, 80) '>' 

READ ( 9 , 82 ) CMD, NUMT 
82 FORMAT (Al, 120) 

IF (LOG) WRITE (1, 821)CMD,NUMT 
821 FORMAT (Al, 15) 

DO 10 1=1,26 

IF (CMD. EQ. CODES ( I) ) GO TO 15 
10 CONTINUE 

WRITE (9,80) CMD/ / ' NOT RECOGNIZED AS VALID COMMAND' 

IF (LOG) WRITE (1,80) CMD/ /' NOT RECOGNIZED AS VALID COMMAND ' 

GO TO 1 

15 CTEMP= ( 1+1) /2 

IF (NUMT .GT. 0 . OR . NUMREQ ( CTEMP ) . EQ. 0) GO TO 20 
WRITE (9, 80) CMD// ' MUST BE FOLLOWED BY A NUMBER' 

IF (LOG) WRITE (1, 80) CMD// ' MUST BE FOLLOWED BY A NUMBER' 

GO TO 1 

C CHECK FOR 'UNDO', ARGUMENT IN RANGE, ETC. 

20 IF (CTEMP. NE. 10) GO TO 30 
IF ( ICOM . LT . 1 ) GO TO 29 

GO TO (21,29,23,29,25,29,29,28,29,29,29,29,29) , ICOM 
C UNDO 'A' 

21 LENGTH (NUM) =LENHOLD 
SAVED (NUM) =SAVEDHOLD 
DO 211 1=1,2 

DO 211 J=l, LENGTH (NUM) 

211 LIST (I, J,NUM)=BACKUPLIST(I, J) 

WRITE (9, 80) 'A COMMAND UNDONE' 

IF (LOG) WRITE (1, 80) 'A COMMAND UNDONE' 

ICOM=CTEMP 
GO TO 1 
C UNDO 'D' 

23 IF (NEWHOLD . EQ . 0 ) GO TO 231 
LENGTH (NEWHOLD) =0 
231 WRITE (9, 80) 'D COMMAND UNDONE' 

IF (LOG) WRITE ( 1 , 80 ) 'D COMMAND UNDONE' 

ICOM=CTEMP 
GO TO 1 
C UNDO 'N' 

25 NEXT=NEXTHOLD 

WRITE (9, 80) 'N COMMAND UNDONE' 

IF (LOG) WRITE (1,80) 'N COMMAND UNDONE' 
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ICOM=CTEMP 
GO TO 1 
C UNDO 'R' 

28 IF (NUM . GT . 0 ) GO TO 285 

C HERE TO UNDO PURGE 

DO 281 1=1,20 
281 LENGTH ( I ) =LENGTHOLD ( I ) 

GO TO 288 

285 LENGTH (NUM) =L£NHOLD 

288 WRITE (9, 80) 'R COMMAND UNDONE' 

IF (LOG) WRITE (1, 80) 'R COMMAND UNDONE' 

ICOM=CTEMP 
GO TO 1 

29 WRITE(9, 80) 'CAN' 'T UNDO' 

IF (LOG) WRITE (1,80) 'CAN' 'T UNDO' 

ICOM=CTEMP 
GO TO 1 

30 IF (NUMT . GT . MAXIN) GO TO 35 

C IF INITIAL COMMAND IS NOT 'N' , ISSUE DEFAULT N 

IF(CTEMP.EQ. 5) GO TO 31 
IF (NEXT . EQ . 0 ) NEXT= 1 

C FINISH CHECKING FOR ARGUMENT IN RANGE 
IF (NUMT. GT. 20) GO TO 35 
IF (NUMT. EQ. 0)GO TO 31 
IF ( LENGTH (NUMT ) .GT.0) GO TO 31 
IF(CTEMP.EQ. l)GO TO 31 

WRITE (9, 80) 'FIRST REFERENCE TO NEW DATA STRUCTURE MUST BE ' 'A' ' CO 
*MMAND ' 

IF (LOG)WRITE(l, 80) 'FIRST REFERENCE TO NEW DATA STRUCTURE MUST BE ' 

* // ' ' ' A' ' COMMAND' 

GO TO 1 

35 WRITE (9, 80) 'NUMERIC VALUE OUT OF RANGE' 

IF (LOG ) WRITE (1, 80) 'NUMERIC VALUE OUT OF RANGE' 

GO TO 1 

C CHECK FOR 'DEFAULT' DATA STRUCTURE REFERENCE 

31 IF (NDEF (CTEMP) ,EQ.0)GO TO 33 
IF (NUMT. GT. 0)GO TO 33 
IF(NLJM.EQ. 0. OR. NUM. GT. 20) GO TO 34 
IF (LENGTH (NUM) .GT.0) GO TO 32 

34 WRITE (9, 80) 'UNABLE TO FIND DEFAULT DATA STRUCTURE REFERENCE FOR ' 

* //CMD//' COMMAND' 

IF ( LOG ) WRITE (1,80) 'UNABLE TO FIND DEFAULT DATA STRUCTURE '// 

* 'REFERENCE FOR '//CMD//' COMMAND' 

GO TO 1 

32 NUMT=NUM 

C ACCEPT COMMAND 

33 ICOMP=ICOM 
ICOM=CTEMP 
NLJMP=NUM 
NUM=NUMT 

GO TO (1000,2000,3000,4000,5000,6000,7000,8000,9000,7000,11000, 

* 12000, 13000) , ICOM 

HERE FOR 'A' (ADD) COMMAND 

1000 LENHOLD= LENGTH (NUM) 

DO 1001 1=1,2 
DO 1001 J=l, LENHOLD 
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1001 BACKUPLIST ( I , J) =LIST (I , J, NUM) 

C SUPPRESS DISPLAY IF IMMEDIATELY PRECEDING COMMAND WAS C<NUM> 

DISPLAY=NUMP . NE . NUM . OR . ICOMP . NE . 2 

CALL CLOSURE (LI ST ( 1, 1, NUM) , LENGTH (NUM) ,NEXT, DISPLAY, .TRUE. ) 

IF ( . NOT . DISPLAY) WRITE (9,80)' PATTERN ADDED ’ 

IF( .NOT. DISPLAY. AND. LOG)WRITE(l, 80) 1 PATTERN ADDED' 

SAVEDHOLD= SAVED ( NUM ) 

SAVED (NUM) = . FALSE . 

GO TO 1 

HERE FOR 'C' (CHECK) COMMAND 

2000 CALL CLOSURE (LIST ( 1, 1, NUM) , LENGTH (NUM) , NEXT, .TRUE. , .FALSE. ) 
GO TO 1 

HERE FOR 'D' (DUPLICATE) COMMAND 

3000 DO 3001 1=1,20 

IF (LENGTH (I) .EQ. 0)GO TO 3002 

3001 CONTINUE 

WRITE (9, 80) 'D COMMAND FAILED- -NO MORE SLOTS AVAILABLE' 

IF (LOG) WRITE (1, 80) 'D COMMAND FAILED — NO MORE SLOTS AVAILABLE' 

NEWHOLD=0 

GO TO 1 

3002 NEWHOLD=I 

LENGTH (NEWHOLD) = LENGTH (NUM) 

DO 3005 1=1,2 

DO 3005 J=l, LENGTH (NUM) 

3005 LIST (I, J, NEWHOLD) =LIST( I, J, NUM) 

WRITE (9, 3080) NUM, NEWHOLD 
IF (LOG) WRITE (1, 3 080) NUM, NEWHOLD 
3080 FORMAT ('DATA STRUCTURE ', 13 , ' COPIED TO SLOT ',13) 

SAVED (NEWHOLD) =SAVED (NUM) 

GO TO 1 

HERE FOR 'E' (EXIT) COMMAND 

4000 DO 4001 1=1,20 

IF (LENGTH (I) . GT . 0 . AND . . NOT . SAVED ( I ) )CALL SAVE (LIST ( 1, 1 , I) , 

* LENGTH (I) ,1) 

4001 CONTINUE 

WRITE(9, 80) 'HIT <CR> FOR EXIT' 

IF (LOG) WRITE (1, 80) 'HIT <CR> FOR EXIT' 

READ ( 9 , 8 0 ) FILENAME 
STOP 

HERE FOR 'N' (NEXT) COMMAND 

5000 NEXTHOLD=NEXT 

IF (NUM . EQ . 0 ) NEXT=NEXT+1 
IF (NUM . GT . 0 ) NEXT=NUM 
IF (NUM . EQ . 0 ) NUM=NUMP 
CALL UNPACK ( INPAT (NEXT) , IN, NI ) 

WRITE (9, 5080) NEXT, FREQ (NEXT) , (IN (I) , 1=1, NI) 

IF (LOG) WRITE (1, 5080)NEXT, FREQ (NEXT) , (IN(I) , 1=1, NI) 

5080 FORMAT ( 'PATTERN' , 15, ' (',F10.4,') = ',3011) 

GO TO 1 
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C HERE FOR 'O’ (OPEN) COMMAND 

C 

6000 CALL OPENOUT 
GO TO 1 
C 

C HERE FOR Q (QUIT) COMMAND 

C 

7000 WRITE(9,80) 'HIT <CR> FOR EXIT' 

IF(LOG)WRITE(l, 80) 'HIT <CR> FOR EXIT' 

READ ( 9 , 80 ) FILENAME 
STOP 
C 

C HERE FOR 'R‘ (REMOVE) COMMAND 

C 

8000 IF (NUM.GT . 0) GO TO 8010 
DO 8005 1=1,20 
LENGTHOLD ( I ) = LENGTH ( I ) 

8005 LENGTH (I) =0 

WRITE (9, 80) 'ALL DATA STRUCTURES PURGED' 

IF ( LOG) WRITE (1, 80) ’ALL DATA STRUCTURES PURGED' 

GO TO 1 

8010 LENHOLD= LENGTH (NUM) 

LENGTH (NUM) =0 
WRITE (9, 8080) NUM 
IF (LOG) WRITE ( 1 , 8 080) NUM 
8080 FORMAT ( ' DATA STRUCTURE ' , 13 , ' PURGED ' ) 

GO TO 1 
C 

C HERE FOR 'S' (SAVE) COMMAND 

C 

9000 IF (NUM . EQ . 0 ) GO TO 9010 

CALL SAVE ( LIST ( 1, 1, NUM) , LENGTH (NUM) , NUM) 

SAVED (NUM )=. TRUE . 

GO TO 1 

9010 DO 9020 1=1,20 

IF (LENGTH (I) . GT . 0 . AND . . NOT . SAVED ( I ) ) CALL SAVE(LIST(1, 1, I) , 

* LENGTH (I) , I) 

SAVED ( I ) = . TRUE . 

9020 CONTINUE 
GO TO 1 
C 

C HERE FOR 'L' (LIST) COMMAND 

C 

11000 NREP=85/ (NI+7) 

ENCODE(18, 11080, FORMAT ) NREP , NI 
11080 FORMAT ( ' ( ( ' , 12, ' (15, 2X, ' , 12 , ’ II) ) ) ' ) 

LINES= (LENGTH (NUM) +NREP-1) /NREP 
CALL UPDATE (LIST (1,1, NUM) , LENGTH (NUM) ) 

DO 11100 ILINE=1, LINES 
LLIM=1+NREP* ( ILINE-1 ) 

ULIM=LLIM+NREP- 1 

IF (ULIM . GT . LENGTH (NUM) ) ULIM= LENGTH (NUM) 

J=0 

DO 11050 I=LLIM, ULIM 
J=J+1 

11050 CALL UNPACK (LIST (2, 1, NUM) ,LBUFFER(1, J) ,NI) 

WRITE (9, FORMAT) (LIST ( 1 , L+LLIM-1 ,NUM) , ( LBUFFER ( I , L ) , 1=1, NI) , L=l, J) 
IF (LOG) 



ERIC 



SUPERCLOSE -- page 7 



20 



* WRITE (1, FORMAT) (LIST ( 1, L+LLIM-1, NUM) , ( LBUFFER ( I , L ) ,I=1,NI) ,L=1, J) 
11100 CONTINUE 

GO TO 1 
C 

C HERE FOR 'M' (MAP) COMMAND 

C 

12000 CALL UPDATE ( LI ST ( 1, 1, NUM) , LENGTH (NUM) ) 

CALL MAP (LIST ( 1, 1, NUM) , LENGTH (NUM) ,NI) 

GO TO 1 
C 

C HERE FOR 'I' (INDEX) COMMAND 

C 

13000 CALL UPDATE (LIST (1,1, NUM) , LENGTH (NUM) ) 

DO 13005 1=1, LENGTH (NUM) 

13005 BACKUPLIST (1,1) =LIST (1,1, NUM) 

CALL SORT ( BACKUPLIST , LENGTH (NUM) ,1,2) 

WRITE (9, 13080) ( BACKUPLIST ( 1 , 1 ) , 1=1, LENGTH (NUM) ) 

IF (LOG) WRITE (1, 13080) (BACKUPLIST (1, 1) , 1=1, LENGTH (NUM) ) 

13080 FORMAT (1515) 

GO TO 1 
•END 

SUBROUTINE CLOSURE (LIST, NIN, NEXT, DISPLAY, UPDATE) 

REAL*8 FREQ (2000) 

INTEGER LIST (2, 5000) , TEMP (3, 1000) , INPAT (2000) , BACKUPLIST (2 , 2000) , 

* IN(30) 

CHARACTER* 80 FILENAME 

LOGICAL OUTFILE, EXIST, DISPLAY, UPDATE, LOG 

COMMON/ START/FREQ, INPAT, BACKUPLIST , MAX IN, ISTART , ISER, NI , 

* OUTFILE, LOG 

80 FORMAT (A) 

IF (NIN . GT . 0 ) GO TO 9 
C FIRST CASE 

IF ( .NOT. DISPLAY) GO TO 3 
CALL UNPACK (INPAT (NEXT ), IN, NI) 

WRITE (9, 81) 0, 1 

IF ( LOG ) WRITE (1,81)0,1 

81 FORMAT ( ' FROM ' , 14 , 1 PATTERNS TO ' , 14 ) 

WRITE (9, 80) 'NEW PATTERNS: ' 

IF ( LOG ) WRITE ( 1 , 80) 'NEW PATTERNS: ' 

WRITE (9, 82) NEXT, (IN (I) ,I=1,NI) 

IF (LOG) WRITE (1,82) NEXT, (IN(I) ,1=1, NI) 

3 IF ( .NOT. UPDATE) RETURN 
LIST ( 1 , 1 ) =NEXT 
LIST ( 2 , 1 )= INPAT (NEXT ) 

NIN=1 

RETURN 

82 FORMAT ( 14, 2X, 3011) 

C CHECK IF INPAT (NEXT) IS ALREADY IN THE LIST, AND STORE IN TEMP IF NOT 

9 CALL SEARCH (INPAT (NEXT) , LIST, NIN, IRES, I PT) 

IF ( IRES . GT . 0 ) GO TO 5 

C NEW PATTERN HAS ALREADY BEEN ADDED — REPLACE SERIAL NUMBER 

LIST ( 1 , IPT) =NEXT 

IF (DISPLAY) WRITE (9, 80) 'PATTERN ALREADY IN LIST' 

IF (DISPLAY. AND. LOG) WRITE( 1, 80) 'PATTERN ALREADY IN LIST' 

RETURN 



5 TEMP ( 1 , 1 ) = INPAT (NEXT ) 
TEMP (2, 1)=NEXT 
TEMP ( 3 , 1 ) =IPT 
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LAST=1 

C CHECK INTERSECTIONS WITH ALL PATTERNS ALREADY IN LIST 
DO 10 1=1, NIN 

J= INTER ( INPAT (NEXT) , LIST (2, 1) ) 

CALL SEARCH (J, LIST, NIN, IRES, IPT) 

IF ( IRES . EQ . 0 ) GO TO 10 
C HERE TO ADD NEW PATTERN TO LIST 
LAST=LAST+ 1 
TEMP (1, LAST) =J 
TEMP (2 , LAST) =ISER 
TEMP(3, LAST) =IPT 
ISER=ISER+1 
10 CONTINUE 

C SORT ADDITIONAL PATTERNS, ELIMINATE DUPLICATES, AND UPDATE LIST 

KEEP=1 

IF(LAST.EQ.l)GO TO 16 
CALL SORT (TEMP, LAST, 3, 3) 

DO 15 1=2, LAST 

IF (TEMP (1,1-1) . NE . TEMP (1,1)) GO TO 12 
TEMPO, I) =-l 
GO TO 15 

12 TEMP (3,1) =TEMP (3,1) +KEEP 
KEEP=KEEP+1 

15 CONTINUE 

16 IF (.NOT. DISPLAY) GO TO 161 
WRITE ( 9 , 8 1 ) NIN , NIN+KEEP 

IF ( LOG ) WRITE ( 1 , 8 1 ) NIN , NIN+KEEP 
WRITE (9,80) ' NEW PATTERNS : * 

IF (LOG) WRITE (1, 80) ’NEW PATTERNS:' 

DO 163 1=1, LAST 

IF (TEMP (3,1) . LT . 0 ) GO TO 163 

CALL UNPACK (TEMP(1, I) , IN, NI) 

C GET INDEX NUMBER OF NEW PATTERNS (IF ANY) 

DO 170 INDEX= 1 , MAXIN 

IF (TEMPO, I) .EQ. INPAT (INDEX) ) GO TO 171 

170 CONTINUE 
INDEX=0 

171 WRITE(9, 82) INDEX, (IN(J) ,J=1,NI) 

IF (LOG) WRITE (1,82) INDEX, (IN(J) , J=1,NI) 

163 CONTINUE 

161 IF ( .NOT. UPDATE) RETURN 
IENDl=NIN 
NIN=NIN+KEEP 
IEND=NIN 

17 IF ( TEMP ( 3 , LAST ) . GT . 0 ) GO TO 18 
LAST=LAST- 1 

GO TO 17 

18 IF ( IEND-TEMP ( 3 , LAST) ) 20 , 25 , 30 

20 WRITE(9, 80) 'A SERIOUS ERROR HAS OCCURRED. EXECUTION ABORTED (1) ' 
IF (LOG) WRITE (1, 80) ’A SERIOUS ERROR HAS OCCURRED. EXECUTION AB'// 
* ' ORTED ( 1 ) ’ 

PAUSE 

STOP 

25 LIST (1 , IE3SJD) =TEMP (2 , LAST) 

LIST ( 2 , IEND) =TEMP ( 1 , LAST ) 

IEND=IEND-1 
LAST=LAST- 1 
IF ( LAST . GT . 0 ) GO TO 17 



o 
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IF (IEND.EQ. IEND1) RETURN 

WRITE (9, 80) 'A SERIOUS ERROR HAS OCCURRED. EXECUTION ABORTED (2) ' 
IF (LOG) WRITE (1, 80) 'A SERIOUS ERROR HAS OCCURRED. EXECUTION AB'// 
* 'ORTED (2) ' 

PAUSE 

STOP 

30 DO 35 1= 1 , IEND-TEMP ( 3 , LAST ) 

LIST ( 1 , I END) =LIST ( 1 , IEND1 ) 

LIST (2 , 1 END) =LIST (2 , IENDl) 

IEND=IEND-1 
35 IENDl=IENDl-l 
GO TO 25 
END 

SUBROUTINE SAVE ( LIST , LENGTH , ID) 

REAL* 8 FREQ (2000) 

INTEGER INPAT (2000) , LIST (2,2000) , BACKUPLIST (2,2000) ,IN(30) 
CHARACTER* 80 COMMENT 
LOGICAL OUTFILE, LOG 

COMMON/ START/FREQ, INPAT, BACKUPLIST, MAXIN, ISTART, ISER.NI, 

* OUTFILE, LOG 

IF ( . NOT . OUTF ILE ) CALL OPENOUT 

WRITE(9, 81) ID 

IF ( LOG ) WRITE ( 1 , 8 1 ) ID 

81 FORMAT ( ' SAVING DATA STRUCTURE ' , 13 ) 

WRITE ( 12 , 82 ) ID 

82 FORMAT ( ' ***** STRUCTURE ',12,' ***** • ) 

WRITE (9, 80) 'ENTER (OPTIONAL) COMMENTS; TERMINATE WITH <CR>' 

IF (LOG) WRITE (1, 80) 'ENTER (OPTIONAL) COMMENTS; TERMINATE '// 

* 'WITH <CR> ' 

1 WRITE (9, 80) '? ' 

READ ( 9 , 8 0 ) COMMENT 

IF (LEN (TRIM (COMMENT) ) .EQ.0) GO TO 5 
WRITE ( 12 , 8 0 ) COMMENT 
IF (LOG) WRITE ( 1 , 80 ) COMMENT 
GO TO 1 
80 FORMAT (A) 

5 DO 10 1=1, LENGTH 

IF (LIST (1, I) . LE. MAXIN) GO TO 9 
C SEARCH TO SEE IF PATTERN OCCURRED IN INPUT LIST 

DO 6 J=l, MAXIN 

IF(LIST(2, I) .EQ. INPAT(J) )GO TO 7 

6 CONTINUE 
GO TO 9 

7 LIST (1, I) =J 

9 BACKUPLIST ( 1, I) =LIST(1, I) 

10 BACKUPLIST (2,1) =LIST (2,1) 

CALL SORT ( BACKUPLIST , LENGTH ,2,2) 

DO 15 1=1, LENGTH 

CALL UNPACK (BACKUPLIST (2,1) , IN, NI) 

15 WRITE(12, 83) BACKUPLIST (1,1), (IN(J) , J=1,NI) 

83 FORMAT (15, IX, 3011) 

RETURN 

END 

SUBROUTINE UPDATE ( LIST , LENGTH ) 

REAL* 8 FREQ (2000) 

INTEGER INPAT (2000) , LIST (2 , 2000) , BACKUPLIST (2 , 2000) 

LOGICAL OUTFILE, LOG 

COMMON/ START /FREQ, INPAT, BACKUPLIST, MAXIN, ISTART, ISER,NI, 
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* OUTFILE, LOG 

DO 11010 1=1, LENGTH 

IF (LIST (1,1) . LE. MAXIN) GO TO 11010 

DO 11005 J=1 , MAXIN 

IF (LIST (2, I) .EQ. INPAT (J) )GO TO 11006 

11005 CONTINUE 
GO TO 11010 

11006 LIST ( 1 , I) =J 
11010 CONTINUE 

RETURN 

END 

SUBROUTINE OPENOUT 
REAL*8 FREQ (2000) 

INTEGER INPAT (2000) , BACKUPLIST (2, 2000) 

CHARACTER* 80 FILENAME 
LOGICAL OUTFILE, EXIST, LOG 

COMMON/START/FREQ, INPAT, BACKUPLIST, MAXIN, ISTART, ISER, NI, 

* OUTFILE, LOG 

IF (OUTFILE) CLOSE ( 12 ) 

OUTFILE= . TRUE . 

WRITE (9, 80) 'OUTPUT FILE NAME' 

IF (LOG) WRITE (1, 80) 'OUTPUT FILE NAME' 

80 FORMAT (A) 

6001 WRITE(9, 80) ' ? ' 

READ ( 9 , 80 ) FILENAME 

INQUIRE (FILE=FILENAME, EXIST= EXIST) 

IF ( .NOT. EXIST) GO TO 6005 

WRITE (9, 80) TRIM (FILENAME) // ' ALREADY EXISTS. PLEASE CHOOSE ANOTHE 
*R NAME' 

GO TO 6001 

6005 OPEN ( 12 , FILE=FILENAME) 

IF (LOG ) WRITE ( 1 , 80 ) FILENAME 

RETURN 

END 

SUBROUTINE SEARCH (NEW, LIST, N, IRES, IPT) 

C RETURN 0 IF PATTERN IS IN LIST, ELSE RETURN POINTER TO NEXT HIGHER 
INTEGER LIST (2 , N) 

IL=1 

IH=N 

1 1= (IL+IH) /2 

IF(NEW-LIST(2, I) )5, 10,15 
5 IH=I-1 

IF ( IH. GE. IL) GO TO 1 
IRES=1 
IPT=I 
RETURN 
10 IRES=0 
IPT=I 
RETURN 
15 IL=I+1 

IF ( IL . LE . IH ) GO TO 1 

IRES=1 

IPT=I+1 

RETURN 

END 

INTEGER FUNCTION INTER ( INlX, IN2X) 

REAL* 8 FREQ (2000) 

INTEGER INPAT (2000) , BACKUPLIST (2, 2000) 
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LOGICAL OUTFILE, LOG 

COMMON/ START/FREQ, INPAT, BACKUPLIST, MAXIN, ISTART, ISER.NI, 

* OUTFILE, LOG 
IN1=IN1X 
IN2=IN2X 
IBIT= ISTART 
INTER=0 

1 IF ( INI . LT . IBIT ) GO TO 5 
IN1=IN1-IBIT 
IF (IN2.LT. IBIT) GO TO 10 
IN2=IN2-IBIT 
INTER= INTER+ IBIT 
GO TO 10 

5 IF (IN2.LT. IBIT) GO TO 10 
IN2=IN2-IBIT 
10 IBIT=IBIT/2 

IF ( IBIT . GT . 0 ) GO TO 1 

RETURN 

END 

SUBROUT INE MAP (LIST, NPATPA , NI ) 

C SUBROUTINE TO READ A SET OF PATTERNS, SORT BY GRADE, DETERMINE EDGES 
C IN LATTICE, AND DERIVE MINIMAL ITEM- ABILITY REQUIREMENTS UNDER 

C ANTICHAIN POSET. 

C PROGRAM LIMITED TO 300 PATTERNS (NODES), EACH UP TO 30 ELEMENTS LONG. 

C DATA STRUCTURE: NODE(l,I) IS GRADE, NODE(2-31,I) IS PATTERN, 

C NODE (32, 1) IS SUCCESSOR COUNT, NODE (3 3, I) IS PTR TO EDGE 

C NODE(34, 1) IS LABEL PASSED FROM CALLING PROGRAM IN LIST(1,J) 

C EDGE IS LIST OF SEQUENCE NUMBERS OF SUCCESSORS 

C GRADE (1,1) IS COUNT OF NODES OF GRADE 1-1, GRADE (2,1) 

C IS SEQUENCE NUMBER OF FIRST NODE OF GRADE 1-1 . 

C JIE(I) IS SEQUENCE NUMBER OF JIE 

C LABEL (I) IS PTR TO LABEL OF SKILL ASSOCIATED WITH JIE (I) 

C WORK (1,1) IS GRADE OF JIE, WORK(2,I) IS NEGATIVE OF 

C SEQUENCE NUMBER OF JIE, WORK (3, I) IS SEQUENCE NUMBER OF 

C LABEL (AFTER SORT) 

C ITEM (1,1) IS SKILL COUNT FOR ITEM I, ITEM(2,I) IS PTR 

C INTO REQS 

C REQS IS LIST OF ITEM SKILL REQUIREMENTS 

C SUC IS WORKING VECTOR USED TO LOCATE SUCCESSORS 

REAL* 8 FREQ (2000) 

INTEGER NODE (34, 500) , EDGE (5000) , JIE(50) ,WORK(3, 50) , ITEM(2,30) , 

* GRADE (2 , 31) , REQS (3000) , LABEL (50) , LIST (2 ,NPAT) , IN(30) 

CHARACTER* 1 LLIST ( 50) , BLANK, X 

CHARACTER* 80 FORMAT 

LOGICAL SUC (500) , OUTFILE, LOG 

INTEGER INPAT (2000 ), BACKUPLIST (2, 2000) 

CHARACTER* 80 FILENAME 

COMMON/ START /FREQ, INPAT, BACKUPLIST, MAXIN, ISTART, ISER, NIX, 

* OUTFILE, LOG 

DATA BLANK/ ' '/, LLIST/ 'A', ’B', 'C', 'D', 'E', 'F', 'G', 'H', 'I' 

2', , R , , , S , , , T , , , U , , , V , , , W , , , X , , , Y', 

•g‘ , 'h' , ' i' , • j ' , 'k 1 , • 1 ' , 'm' , 'n' , 'o' 

'W , 1 x ' / , GRADE/ 62*0/ , MAXGRADE/0/ 

'FULL 1 NODES— FIRST 'NULL' 

[=1 , NI 

201 IN(I) =0 

J=IPACK(IN,NI) 



: 'L' , 'M' , 'N' , ‘O’ , 


•P' , • 


r ’b' , 'c' , 'd‘ , 'e' 


, 'f. 


r 'r' , 's' , 't' , 'u‘ 


, 'V, 


NPAT=NPATPA 




CHECK FOR ’NULL' 


AND 


DO 201 1=1, NI 





'J' , 'K 1 , 
'Z 1 , 'a 1 , 

’ 'P' , 'q' , 
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DO 202 I=1,NPAT 
IF (LIST (2, I) .EQ.J)GO TO 205 
202 CONTINUE 

WRITE(9 , 80) 'LIST AUGMENTED WITH ' 'NULL' * * 

IF (LOG) WRITE (1, 80) 'LIST AUGMENTED WITH ' 'NULL' 1 ' 
NPAT=NPAT+1 
LIST (2 , NPAT) =J 
LIST ( 1, NPAT) =0 
C NEXT 'FULL' 

205 DO 206 1=1, NI 

206 IN(I) =1 
J=IPACK(IN, NI) 

DO 208 1=1, NPAT 
IF(LIST(2, I) .EQ. J)GO TO 210 

208 CONTINUE 

WRITE (9, 80) 'LIST AUGMENTED WITH * 'FULL' ' ' 

IF (LOG) WRITE (1, 80) 'LIST AUGMENTED WITH ' 'FULL' ' ' 
NPAT=NPAT+ 1 
LIST (2, NPAT) =J 
LIST (1, NPAT) =0 
80 FORMAT (A) 

210 NI1=NI+1 

DO 10 IPAT=1, NPAT 
NODE(34, IPAT) =LIST ( 1 , IPAT) 

CALL UNPACK (LIST (2, IPAT) , NODE (2 , IPAT) ,NI) 

NODE( 1 , IPAT) =0 
DO 4 1=2, Nil 

4 NODE (1,1 PAT ) =NODE (1,1 PAT ) +NODE (1,1 PAT ) 

NODE(32, IPAT) =0 
J=NODE(l, IPAT) 

GRADE ( 1 , J+l ) =GRADE ( 1 , J+l ) +1 
IF ( J . GT . MAXGRADE) MAXGRADE= J 

10 CONTINUE 

MAXG 1 = MAXGRADE + 1 

C SORT BY GRADE AND BY PATTERN WITHIN GRADE; 

C FINISH BUILDING GRADE TABLE 

DO 9 1=1, NPAT 
DO 9 J=2 , Nil 
9 NODE ( J , I ) =-NODE ( J , I ) 

CALL SORT (NODE, NPAT, 3 4, 34) 

DO 11 1=1, NPAT 
DO 11 J=2,NI1 

11 NODE(J, I) =-NODE(J, I) 

GRADE (2, 1 ) = 1 

DO 12 1=2 ,MAXG1 

12 GRADE(2, 1)=GRADE(1, 1-1 ) +GRADE(2 , 1-1) 

C FIND SUCCESSORS 

IPT=0 

NODE (32, NPAT ) = 0 
DO 20 I PAT= 1 , NPAT 
IGD=NODE ( 1 , IPAT) 

IF ( IGD.EQ. MAXGRADE. AND. I PAT. NE. NPAT) GO TO 21 
IF ( IGD.NE. MAXGRADE. AND. I PAT. EQ. NPAT) GO TO 21 
IF ( IPAT. EQ. NPAT) GO TO 22 
IFND=IGD+2 

DO 13 IFND=IFND, MAXG1 
IF (GRADE ( 1 , IFND) . EQ . 0 ) GO TO 13 
NSTART=GRADE (2 , IFND) 
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GO TO 131 

13 CONTINUE 

WRITE(9, 80) 'SERIOUS ERROR: FELL OUT OF LOOP AT 13' 

IF (LOG) WRITE ( 1, 80) 'SERIOUS ERROR: FELT, OUT OF LOOP AT 13' 

GO TO 21 

131 NODE ( 32 , IPAT ) =0 

NODE (33 , IPAT) =IPT+1 
DO 16 ICHEK=NSTART , NPAT 
DO 14 1=2, Nil 

IF(NODE(I, IPAT) .GT.NODE(I, ICHEK) )GO TO 15 

14 CONTINUE 

SUC (ICHEK) =. TRUE. 

GO TO 16 

15 SUC ( ICHEK )=. FALSE. 

16 CONTINUE 

DO 18 ICHEK=NSTART , NPAT 

IF ( .NOT. SUC (ICHEK )) GO TO 18 

IF ( ICHEK. EQ. NPAT) GO TO 19 

IST=ICHEK+1 

DO 17 ICKl=IST, NPAT 

IF ( . NOT . SUC ( ICKl ) ) GO TO 17 

DO 161 1=2, Nil 

IF (NODE (I, ICHEK) .GT. NODE (I, ICKl) ) GO TO 17 
161 CONTINUE 

SUC ( ICKl )=. FALSE. 

17 CONTINUE 

18 CONTINUE 

19 DO 191 ICHEK=NSTART , NPAT 

IF ( .NOT. SUC (ICHEK) ) GO TO 191 
NODE ( 32 , IPAT ) =NODE ( 32 , IPAT ) +1 
IPT=IPT+1 
EDGE(IPT) =ICHEK 
191 CONTINUE 

20 CONTINUE 

WRITE (9, 80) ' PROBLEM— FELL THROUGH LOOP AFTER 20' 

IF (LOG)WRITE(l, 80) ' PROBLEM- -FELL THROUGH LOOP AFTER 20' 

21 WRITE (9, 80) 'SERIOUS ERROR: NODE SET IS NOT A GRADED LATTICE' 

IF (LOG) WRITE (1, 80) 'SERIOUS ERROR: NODE SET IS NOT A GRADED'// 

* ' LATTICE' 

WRITE(9, 83) ( (NODE(I,J) ,1=1,34) ,J=1,NPAT) 

IF ( LOG ) WRITE ( 1 , 83) ( (NODE(I, J) , 1=1, 34) , J=1,NPAT) 

83 FORMAT (14, 3011,313) 

WRITE (9, 84) GRADE 

IF ( LOG ) WRITE ( 1 , 8 4 ) GRADE 

84 FORMAT( (5(215, 5X) ) ) 

READ(9, 80)X 

STOP 

NORMAL EXIT FROM LOOP (ONLY NODE FOR WHICH THERE ARE ZERO NODES 
OF NEXT HIGHER GRADE IS SINGLE NODE OF HIGHEST GRADE) 

NEXT MUST FIND JIE'S AND ASSIGN LABELS TO CORRESPONDING ABILITIES 

22 NJIE=0 

DO 25 IPAT=1,NPAT 

IF (NODE (32, IPAT) .GT.l)GO TO 25 

IF ( IPAT. EQ. NPAT) GO TO 26 

IF (NODE (32, IPAT) .EQ. l)GO TO 23 

WRITE (9, 80) 'SERIOUS PROBLEM AT LABEL 22+5' 

IF (LOG) WRITE (1, 80) 'SERIOUS PROBLEM AT LABEL 22+5' 

GO TO 21 
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23 NJIE=NJIE+1 
JIE (NJIE) =IPAT 
WORK ( 1 , NJIE) =NODE ( 1 , IPAT) 

25 CONTINUE 

WRITE(9, 80) 'ERROR: FELL THROUGH LOOP TO 25' 

IF(LOG)WRITE(l, 80) 'ERROR: FELL THROUGH LOOP TO 25' 

GO TO 21 

26 WRITE (9, 85) NJIE 

IF ( LOG ) WRITE ( 1 , 85) NJIE 

85 FORMAT (15, ' ABILITIES REQUIRED') 

DO 30 1=1, NJIE 

WORK (2 , I) =-I 
30 WORK (3 , I) =1 

CALL SORT (WORK, NJIE, 3,3) 

DO 32 1=1, NJIE 
J =WORK (3,1) 

32 LABEL ( I ) = J 

C FIND SKILL REQUIREMENTS FOR EACH ITEM 
IPT=0 

DO 35 IT=1 , NI 
ITl=IT+l 
ITEM (1, IT) =0 
ITEM (2 , IT) =IPT+1 
DO 35 J=1,NJIE 
JSEQ=JIE ( J) 

IF (NODE(ITl, JSEQ) .EQ.l)GO TO 35 
ITEM(1, IT) =ITEM(1, IT)+1 
IPT=IPT+1 

REQS ( I PT ) =LABEL ( J ) 

35 CONTINUE 

C HERE TO OUTPUT LATTICE AND ITEM-ABILITY MAP 

WRITE (9,80) ' ' 

IF(LOG)WRITE(l, 80) ' ' 

LINES=2 

ENCODE (21, 86,FORMAT)NI-l,NI+14 

86 FORMAT ( ' (314, ' , 12 , ' II, (T ' , 12 , ' , 1014) ) ' ) 

DO 40 IPAT=1 , NPAT 

Jl=NODE(33, IPAT) 

J2=J1+N0DE(32, IPAT) -1 

WRITE(9, FORMAT) NODE (34, IPAT) , (NODE(I, IPAT) , 1=1, Nil) , 

* (NODE (34, EDGE (I) ) , I=Jl, J2) 

IF (LOG) WRITE (1, FORMAT) NODE (34, IPAT) , (NODE(I, IPAT) , 1=1, Nil) , 

* (NODE(34,EDGE(I) ) , I=J1, J2) 

LINES=LINES+ ( J2 - Jl+9 ) /10 
IF ( J1 . GE. J2 ) LINES=LINES+1 
IF (LINES. LE. 25) GO TO 40 

WRITE (9, 80) ' (TYPE <CR> TO CONTINUE) ' 

READ(9, 80)X 
LINES=0 
40 CONTINUE 

WRITE (9, 80) ' (TYPE <CR> TO CONTINUE) ' 

READ(9, 80)X 
WRITE (9, 80) ' ' 

WRITE (9, 80) ' ITEM- ABILITY REQUIREMENTS ASSUMING ANTICHAIN POSET' 
IF (LOG) 

*WRITE(1, 80) ' ITEM- ABILITY REQUIREMENTS ASSUMING ANTICHAIN POSET' 
DO 45 IT=1,NI 
Jl=ITEM (2 , IT) 
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J2=ITEM(1, IT) 

IF ( J2 . LT . 2 ) GO TO 44 
CALL SORT (REQS ( J1 ) ,J2, 1,1) 

44 J2=Jl+ITEM ( 1 , IT) -1 

WRITE (9, 88) IT, (LLIST(REQS(I) ) ,I=Jl,J2) 

IF (LOG) WRITE (1, 88) IT, (LLIST (REQS (I) ) , I=J1,J2) 

45 CONTINUE 

88 FORMAT ( 14, (T10, 30A1) ) 

RETURN 

END 

INTEGER FUNCTION IPACK(IN,NI) 

INTEGER IN(NI) 

IPACK=0 
DO 5 1=1, NI 
5 IPACK=2 * IPACK+IN ( I ) 

RETURN 

END 

SUBROUTINE UNPACK ( Jl , IN , NI ) 

REAL* 8 FREQ (2000 ) 

INTEGER INPAT ( 2000 ) , BACKUPLIST (2,2000) 

INTEGER IN (NI) 

LOGICAL OUTFILE, LOG 

COMMON/ START/FREQ, INPAT, BACKUPLIST, MAXIN, ISTART, ISER,NN, 

* OUTFILE, LOG 
1=1 
J=J1 

IBIT=ISTART 

1 IF(J-IBIT) 5, 10, 10 
5 IN(I)=0 

GO TO 15 
10 IN ( I) =1 
J=J-IBIT 
■15 1=1+1 

IBIT=IBIT/2 

IF ( IBIT . GT . 0 ) GO TO 1 

RETURN 

END 

SUBROUTINE SORT ( IBUF, N, LEN, ISKIP) 

GENERAL-PURPOSE SORTING SUBROUTINE, USING 'QUICK SORT' ALGORITHM 
IBUF IS VECTOR TO BE SORTED, N IS NUMBER OF ELEMENTS IN VECTOR, 

LEN IS NUMBER OF WORDS IN EACH ELEMENT, AND ISKIP (> LEN) IS NUMBER 
OF WORDS SEPARATING THE BEGINNING OF SUCCESSIVE VECTOR ELEMENTS 
LEN MUST BE LESS THAN OR EQUAL TO THE DIMENSION OF PIVOT 
INTEGER IBUF ( ISKIP, N) , LV(40) ,UV(40) , PIVOT, P 
LV ( 1 ) = 1 ; UV ( 1 ) =N ; P=1 
DO WHILE (P.GT.0) 

IF(LV(P) .GE.UV(P) ) THEN 
P=P-1 
ELSE 

I=LV(P) -1 
J=UV(P) 

pivot=j 
1 1=1+1 

IF(I.GE.J) GO TO 10 
DO 2 KX=1 , LEN 

IF ( IBUF (KX, I) - IBUF (KX, PIVOT) ) 1, 2 , 4 

2 CONTINUE 
GO TO 1 





SUPERCLOSE — page 16 



29 



4 J=J-1 

IF(J.LE.I) GO TO 10 
DO 6 KX=1, LEN 

IF ( IBUF (KX, J) -IBUF (KX, PIVOT) )7,6,4 

6 CONTINUE 
GO TO 4 

7 DO 8 KX=1,LEN 

L=IBUF (KX, I) 

IBUF(KX, I)=IBUF(KX, J) 

8 IBUF (KX, J) =L 
GO TO 1 

10 DO 12 KX=1,LEN 

IF ( IBUF ( KX , I) -IBUF (KX, PIVOT) ) 13, 12, 14 

12 CONTINUE 

13 IF ( I. EQ. PIVOT) GO TO 16 
1 = 1+1 

14 DO 15 KX=1,LEN 
L=IBUF (KX, I) 

IBUF(KX, I ) =IBUF (KX, PIVOT) 

15 IBUF (KX, PIVOT) =L 

16 IF (I-LV(P) .LT. UV ( P ) - I ) THEN 

LV(P+1) =LV ( P) 

UV(P+1)=I-1 

LV(P)=I+1 

ELSE 

LV(P+1) =1+1 
UV(P+1)=UV(P) 

UV(P)=I-1 
END IF 
P=P+1 
END IF 
REPEAT 

RETURN ' ' 

END 




ERIC 
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(* : Title: Ability/Task Representations *) 

(* : Author: Edward H. Haertel *) 

(* {Summary: 

This package implements a set of functions useful in 
the analysis and representation of discrete ability and 
task structures, as proposed by Haertel & Wiley (1993) . 
It extends the package 

Combinatorica, Copyright 1990-1993 by Steven S. Skiena 
*) 

(* : Discussion: 

Comments should be directed to the author at 
haertel01eland.stanford.edu or 415-725-1251. 

*) 

(* : Context : DiscreteMath'Combinatorica' 

*) 



(* : Package Version: 1.0, October 1994 
*) 



ln[1]:= 

<<DiscreteMath' Combinatorica' 

ln[2]:= . 

(♦Define lower-case letters as corresponding text 
strings for use as (atomic) ability labels *) 



a = " a " 



3 



n j n 



S = n S " 



;b="b";c="c" ;d="d" ;e="e";f="f ";g="g" ;h= n h" ;i="i"; 
;k="k n ; l = "l n ;m= n m" ;n= n n n ;o="o n ;p="p" ;q= ,, q" ; r= n r" ; 
; t="t" ;u="u" ;v="v" ;w="w" ;x= n x n ;y="y" ; z = " z " ; 



ln[6]:= 

(* AList [AbilityCombinationList] returns a list of the 
primative abilities included in one or more ability 
combinations. *) 



AList [acomb_List] : = 

Union [Flatten [Characters /® Flatten [acomb] ] ] 

General : : spelll : 

Possible spelling error: new symbol name "AList" 
is similar to existing symbol "List". 
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ln[8]:= 

(* JlEs [DepList ] returns a list of the join-irreducible 
elements implied by a list of (pairwise) ability 
dependencies. The abilities list must be a list of 
elements of the form {antecedent-ability-label, 
dependent-ability-label} or {ability-label} or 
ability-label, or any mixture. The latter two forms 
permit referencing of abilities that do not enter into 
antecedent/postcedent relations with any other 
abilities *) 

JIEs [dep_List ] : =JIE$Temp /; (JIE$Temp= 

Module [ {alist,n, dummy-vertices, ttemp,utemp} , 

(alist=AList [dep] ;n=Length[alist] ; 
dummyvertices=Table [{0,0}, {n}] ; 
ttemp=Table [0, {n} , {n} ] ; 

Scan[ (ttemp [ [# [ [1] ] , # [ [2] ] ]]=1)&, 

Map [ {Position [alist,#[ [1] ]] [ [1,1] ] , 

Position [alist, # [ [2] ] ] [ [1,1] ] }&, 

Select [dep, (ListQ[#] && Length [#] ==2)&] 

], 

1] ; 

utemp=Edges [TransitiveClosure [ 

Graph [ttemp, dummy-vertices] ] ]; 

If [AcyclicQ [Graph [utemp, dummy-vertices] , Directed] , 
StringJoin /<? 

Map [alist [ [Flatten [Position [#,1] ,2] ] ]&, 
Transpose [utemp+ldentityMatrix[n] ] 

], 

$Failed 

] 

)]; JIE$Temp =!= $Failed) 



General : : spelll : 

Possible spelling error: new symbol name "utemp" 
is similar to existing symbol "ttemp”. 
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In [10]:= 

(* APat terns [JiEList] returns a list of all possible 
ability patterns generated by the poset represented by 
a list of join-irreducible elements (i.e., the nodes 
of the distributive lattice having a given set of 
join-irreducible elements) . 

*) 

APattems [ j ies_Lis t ] : a 
Map [ 

(Apply [St ring Join,#] )*, 

Union [ 

Map [Union, Characters /& 

( (Apply [StringJoin,#] )& /<? Subsets [j ies] ) 

] 

] 

] 

(* Here is an example of the use of JiEs and 
APattems *) 

J^®s [ (h, (d , b } , (b, a } , (a,c) , (g), (h, a } } ] 

{abdh, bd, abcdh, d, g, h) 

APattems [%] 

{, d, g, h, bd, dg, dh, gh, bdg, bdh, dgh, abdh, bdgh, 
abcdh, abdgh, abcdgh) 

ln[12]:= 

(* Poset [JiEList ] returns a graph of the ability poset 
(partially ordered set) corresponding to a list of 
join- irreducible elements. The graph is a Hasse 
diagram presented left-to-right, with independent 
components left- justified. *) 

Poset [JlE_List ] : — 

Module [ (n=Length [ JIE] , i, j , rawgraph) , 
rawgraph=HasseDiagram [ 

Graph [ 

Table [ 

If [And @@ (StringMatchQ [ JIE [ [ j ] ] , 

"♦"otto"*"]* /® Characters [JIE [ [i] ] ]), 
1, 0 

], 

(i,n> , { j ,n> ] , 

Table [ {0, 0), {n}] ] ]; 

Graph [First [rawgraph] , 

{# [ [2] ] , -# [ [1] ] >& /& Last [rawgraph] 

] 

] 
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(* Here is an illustration of the use of Poset 

Note that it does not work exactly as intended; 
In general, the problem of finding pleasing 
planar representations of graphs is extremely 
difficult. The embeddings created by Poset 
should be taken as first approximations. *) 
ShowLabeledGraph [Poset [ 

{ "abdh", "bd", "abcdh" , "d", "g", "h"}], 

{ "abdh" , "bd", "abcdh", "d", "g", "h"}] 




h bd 9 

-Graphics- 
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ln[14]:= 

(* The following is a demonstration of the use of the 
above routines together with Combinatorics routines 
to construct a complete Hasse diagram corresponding 
to the full set of ability-states implied by a given 
set of pairwise dependencies (and single elements) . 

Note that the function pathQ tests for a subset 
relation between any pair of ability-state labels. *) 

pathQ [x_String,y_String] := 

Apply [And, Map [StringMatchQ [y, "* n <>#<>"*" ] &, 
Characters [x] ] ] 

AStateEmbed [demolist_List] : = 

Module [ {abilitylist } , 

ShowLabeledGraph [ 

HasseDiagram [ 

Make Graph [ 

nodelist=APat terns [ 

JIEs [demolist] 

], 

pathQ 

] 

], 

node list 

] ] 

demolist={ {a,b> , {a,c>, {d,e>, {a,e>, f ) 

AStateEmbed [demolist ] 

Out(19]= 

{{a, b}, {a, c}, {d, e}, {a, e}, f} 
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Out[20]= 

-Graphics- 

ln[21 ]:= 

(* Here are JlEs, Posets, and Ability State Lattices 
for the five nonisomorphic structures on 3 binary 
abilities. (Structures are specified initially in 
terms of pairwise dependencies between abilities.) 

*) 

structures={ (a,b,c) , 

{ (a,b) ,c) , 

{ { a / b } / { a / c } } / 

{ { a / c } / (b/ c } } / 

{{a,b}, {b,c})) 

TableForm[ jiesets=JlEs [#] & /<? structures] 

ShowLabeledGraph[Poset [#],#] & /<? jiesets 

AStateEmbed [#] & /& structures 

Out[23]= 

{{a, b, c), {{a, b) , c} ( {{a, b} , {a, c}) ( 

{{a, c } , (b, c } } , {{a, b) , (b, c}}} 
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Out[24]//T ableForm= 
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Out[25]= 

{-Graphics-, -Graphics-, -Graphics-, -Graphics-, -Graphics-} 
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Out[ 26 ]= 

{-Graphics-, -Graphics-, -Graphics-, -Graphics-, -Graphics-} 




42 



U.S. Department of Education 

Office of Educational Research and Improvement (OERI) 
Educational Resources Information Center (ERIC) 

REPRODUCTION RELEASE 

(Specific Document) 



1. DOCUMENT IDENTIFICATION: 




Title: Software for the Application of Discrete Latent 

Structure Models to Item Response Data 




Author(S): Edward H. Haertel 





Corporate Source: 

Stanford University 


Publication Date: 



II. REPRODUCTION RELEASE: 








i n *. ,n 0r ^. to J*“®mlnate as wW ® , >' ■» possible time)/ and significant materials of Interest to the educational community documents announced 
In the monthly abstract Journal of the ERIC system, Resources In Education (RIE), are usually made available to users In microfiche reorodueed 
E2? *** "* d media, and sold through the ERIC Document Reproduction Service (EDRS) or other ERIC 2SL?S!d5to 

0 source o each document, and, If reproduction release is granted, one of the following notices is affixed to the document 



If permission Is granted to reproduce and disseminate the Identified document, please CHECK ONE of 
tn® bottom of tho page. 



the following two options and sign at 



0 

t 

Chock here 
For Level 1 Release: 
Permitting reproduction In 
microfiche (4“ * 6“ film) or 
other ERIC archival media 
(e.g., electronic or optical) 
mnd paper copy. 



The sample sticker shown below will be The sample sticker shown below will be 
affixod to all Laval 1 documents affixed to all Level 2 documents 



PERMISSION TO REPRODUCE AND 




PERMISSION TO REPRODUCE AND 


DISSEMINATE THIS MATERIAL 




DISSEMINATE THIS 


HAS BEEN GRANTED BY 




MATERIAL IN OTHER THAN PAPER 






COPY HAS BEEN GRANTED BY 






1 I* 


bSr 

cf 










XT 


TO THE EDUCATIONAL RESOURCES 




TO THE EDUCATIONAL RESOURCES 


INFORMATION CENTER (ERIC) 




INFORMATION CENTER (ERIC) 


Level 1 


Level 2 



□ 

t 

Check here 
For Level 2 Release: 

Permitting reproduction rt 
microfiche (4‘ x 6" film) or 
other ERIC archival media 
(e.g., electronic or optical), 
but not in paper copy. 



Documents will be processed as Indicated provided reproduction quality permits. If permission 
to reproduce is granted, but neither bo* is checked, documents will be processed at Level 1. 



Sign 

here-* 

please 



'I hereby grant to t 

skss sr jsss£t R r, ductk,n 

** e ^ 9 !H con,ra ? lon r0< ) ulf6 * permission from the copyright holder. Exception Is made for non-profit 
reproduction by libraries and other service agencies to satisfy information needs of educators in response to discrete inquiries. * 



Signature; 



j Printed ftamo/Posftion/Tido: 



. *~\ / A j r iintvw ISCUIld/rDSIUWVIUW. 

Cl - Jjs | Edward H . Haertel, Professor 

Ewaaiiof^ ; * - - - — -iw. — 



S^aliliaiibTWd^ 

School of Education 
Stanford University 
Stanford, CA 94305-3096 



iTflKpKorS: 

j 415/725-1251 

ii 



i*PAX r 

• 415/725-7412 



t-l^iTA’ddresfi: 

| haer tel@leland . 

i stanford.edu 



jBaie* 

! 7/26/96 

i 

I 



O 



(over) 




/ 



III. DOCUMENT AVAILABILITY INFORMATION (FROM NON-ERIC SOURCE): 

It permission to reproduce is not granted to ERIC, or, if you wish ERIC to cite the availability of the document from another source, 
please provide the following informallon regarding the availability of the document. (ERIC will not announce a document unless It Is 
publicly available, and a dependable source can be specified. Contributors should also be aware that ERIC selection criteria are 
significantly more stringent for documents that cannot be made available through EDRS.) 



Publisher/Distributor: 



Address: 



Price: 



IV. REFERRAL OF ERIC TO COPYRIGHT/REPRODUCTION RIGHTS HOLDER: 



If the right to grant reproduction release is held by someone other than the addressee, please provide the appropriate name and address: 



Name: 



Not applicable 



Addreee: 



V. WHERE TO SEND THIS FORM: 



Send this form to the following ERIC Clearinghouse: 



However, If solicited by the ERIC Facility, or if making an unsolicited contribution to ERIC, return this form (and the document belno 
contributed) to: * 



(Rev. 6/96) 




ERIC Processing and Reference Facility 
1100 West Street, 2d Floor 
Laurel, Maryland 20707-3596 

Telephone: 301-497-4060 
Toll Free: 800-799-3742 
FAX: 301-953-0263 
e-mail: ericfac@lnet.ed.gov 
WWW: http://erlctac.plccard.csc.com 



